home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / image.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  59KB  |  1,489 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; CLX Image functions
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;;
  22. ;;; Change history:
  23. ;;;
  24. ;;;  Date    Author    Description
  25. ;;; -------------------------------------------------------------------------------------
  26. ;;; 10/14/87    LGO    Created
  27. ;;; 11/03/87    LGO    Re-written to split out image-x image-xy and image-z types
  28. ;;;  5/18/88    DLC     Moved BYTE-REVERSE to before it was used for inline expansion
  29.  
  30. ;;; TO DO:
  31. ;;; 1. Write lispm versions of the conversion functions that use BITBLT
  32. ;;; 2. Export VISUAL-INFO?  What support does XLIB give for visuals?
  33. ;;; 3. Does bit-lsb-first-p apply to z-format 4 bit-per-pixel?
  34. ;;; 4. What does byte-lsb-first-p mean for z-format 24 bit-per-pixel?
  35. ;;; 5. Why does read-bitmap-file need :bit-lsb-first-p t to create-image?
  36. ;;; 6. This hasn't been tested with depths 4 16 24 or 32 (I don't have
  37. ;;;    access to a server that supports these visuals - LGO)
  38.  
  39. (in-package 'xlib :use '(lisp))
  40.  
  41. (export '(bitmap
  42.       pixarray 
  43.       image
  44.       image-width
  45.       image-height
  46.       image-depth
  47.       image-plist
  48.       image-name
  49.       image-x-hot
  50.       image-y-hot
  51.       image-red-mask
  52.       image-blue-mask
  53.       image-green-mask
  54.       image-x
  55.       image-xy
  56.       image-z
  57.       image-x-p
  58.       image-xy-p
  59.       image-z-p
  60.       image-xy-bitmap-list
  61.       image-z-bits-per-pixel
  62.       image-z-pixarray
  63.       create-image
  64.       get-image
  65.       put-image
  66.       copy-image
  67.       read-bitmap-file
  68.       write-bitmap-file
  69.       bitmap-image
  70.       image-pixmap))
  71.  
  72. (deftype bitmap () '(array bit (* *)))
  73.  
  74. (deftype pixarray () '(or (array pixel (* *))
  75.               (array card16 (* *))
  76.               (array card8 (* *))
  77.               (array (unsigned-byte 4) (* *))
  78.               (array bit (* *))))
  79.  
  80. (defstruct (image (:constructor nil) (:copier nil))
  81.   ;; Public structure
  82.   (width 0 :type card16 :read-only t)
  83.   (height 0 :type card16 :read-only t)
  84.   (depth 1 :type card8 :read-only t)
  85.   (plist nil :type list))
  86.  
  87. ;; Image-Plist accessors:
  88. (defun image-name (image) (getf (image-plist image) :name))
  89. (defun image-x-hot (image) (getf (image-plist image) :x_hot))
  90. (defun image-y-hot (image) (getf (image-plist image) :y_hot))
  91. (defun image-red-mask (image) (getf (image-plist image) :red-mask))
  92. (defun image-blue-mask (image) (getf (image-plist image) :blue-mask))
  93. (defun image-green-mask (image) (getf (image-plist image) :green-mask))
  94.  
  95. (defsetf image-name (image) (name) `(set-image-property ,image :name ,name))
  96. (defsetf image-x-hot (image) (x) `(set-image-property ,image :x_hot ,x))
  97. (defsetf image-y-hot (image) (y) `(set-image-property ,image :y_hot ,y))
  98. (defsetf image-red-mask (image) (mask) `(set-image-property ,image :red-mask ,mask))
  99. (defsetf image-blue-mask (image) (mask) `(set-image-property ,image :blue-mask ,mask))
  100. (defsetf image-green-mask (image) (mask) `(set-image-property ,image :green-mask ,mask))
  101.  
  102. (defun set-image-property (image name value) (setf (getf (image-plist image) name) value))
  103.  
  104. (defvar *empty-data-x* (make-sequence '(array card8 (*)) 0))
  105. (proclaim '(type (array card8 (*)) *empty-data-x*))
  106. (defvar *empty-data-z* (make-array '(0 0) :element-type 'bit))
  107. (proclaim '(type pixarray *empty-data-z*))
  108.  
  109. (defstruct (image-x (:include image))
  110.   ;; Use this format for shoveling image data
  111.   ;; Private structure. Accessors for these NOT exported.
  112.   (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
  113.   (bytes-per-line 0 :type card16)
  114.   (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
  115.   (bit-lsb-first-p nil :type boolean)        ; Bit order
  116.   (byte-lsb-first-p nil :type boolean)        ; Byte order
  117.   (data *empty-data-x* :type (array card8 (*)))); row-major
  118.  
  119. (defstruct (image-xy (:include image))
  120.   ;; Public structure
  121.   ;; Use this format for image processing
  122.   (bitmap-list nil :type list)) ;; list of bitmaps
  123.  
  124. (defstruct (image-z (:include image))
  125.   ;; Public structure
  126.   ;; Use this format for image processing
  127.   (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
  128.   (pixarray *empty-data-z* :type pixarray))
  129.  
  130. (defun create-image (&key width height
  131.              depth data plist name x-hot y-hot
  132.              red-mask blue-mask green-mask
  133.              bits-per-pixel format bytes-per-line
  134.              byte-lsb-first-p bit-lsb-first-p )
  135.   ;; Returns an image-x image-xy or image-z structure, depending on the
  136.   ;; type of the :DATA parameter.
  137.   (declare
  138.     (type (or null card16) width height)    ; Required
  139.     (type (or null card8) depth)        ; Defualts to 1
  140.     (type (or (array card8 (*))            ;Returns image-x
  141.           cons ; (list bitmap)        ;Returns image-xy
  142.           pixarray) data)            ;Returns image-z
  143.     (type list plist)
  144.     (type (or null stringable) name)
  145.     (type (or null card16) x-hot y-hot)
  146.     (type (or null pixel) red-mask blue-mask green-mask)
  147.     (type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
  148.     
  149.     ;; The following parameters are ignored for image-xy and image-z:
  150.     (type (or null (member :bitmap :xy-pixmap :z-pixmap))
  151.       format)                ; defaults to :z-pixmap
  152.     (type (or null card16) bytes-per-line)
  153.     (type boolean byte-lsb-first-p bit-lsb-first-p))
  154.   (declare-values image)
  155.   (let (image)
  156.     ;; If image is a list of one element, use image-z
  157.     ;; (when (and (consp data) (not (cdr data))) (setq data (car data)))
  158.     (etypecase data
  159.       (vector                    ; image-x
  160.        (unless depth (setq depth 1))
  161.        (unless width (required-arg width))
  162.        (unless height (required-arg height))
  163.        (unless bytes-per-line
  164.      (setq bytes-per-line (floor (length data) (* (or bits-per-pixel depth) height))))
  165.        (setq image (make-image-x :width width :height height
  166.                  :depth depth :plist plist
  167.                  :bits-per-pixel (or bits-per-pixel depth)
  168.                  :format (or format (if (= depth 1) :xy-pixmap :z-pixmap))
  169.                  :bytes-per-line bytes-per-line
  170.                  :byte-lsb-first-p byte-lsb-first-p
  171.                  :bit-lsb-first-p bit-lsb-first-p
  172.                  :data data)))
  173.       (cons                    ; image-xy
  174.        (unless width (setq width (array-dimension (car data) 1)))
  175.        (unless height (setq height (array-dimension (car data) 0)))
  176.        (setq image (make-image-xy :width width :height height :plist plist
  177.                   :depth (or depth (length image))
  178.                   :bitmap-list data)))
  179.       
  180.       (pixarray                    ; image-z
  181.        (unless width (setq width (array-dimension data 1)))
  182.        (unless height (setq height (array-dimension data 0)))
  183.        (unless depth (setq depth (pixarray-depth data)))
  184.        (setq bits-per-pixel (ash 1 (integer-length (1- (or bits-per-pixel depth))))) ;; round up to power of 2
  185.        (setq image (make-image-z :width width :height height
  186.                 :depth depth :plist plist
  187.                 :bits-per-pixel bits-per-pixel
  188.                 :pixarray data))))
  189.     (when name (setf (image-name image) name))
  190.     (when x-hot (setf (image-x-hot image) x-hot))
  191.     (when y-hot (setf (image-y-hot image) y-hot))
  192.     (when red-mask (setf (image-red-mask image) red-mask))
  193.     (when blue-mask (setf (image-blue-mask image) blue-mask))
  194.     (when green-mask (setf (image-green-mask image) green-mask))
  195.     image))
  196.  
  197. (defun scanline-byte-round (scanline-length scanline-pad)
  198.   (ecase scanline-pad
  199.     (8 scanline-length)
  200.     (16 (wround scanline-length))
  201.     (32 (lround scanline-length))))
  202.  
  203. (defun pixarray-depth (pixarray)
  204.   (or (second (assoc (array-element-type pixarray)
  205.              '((bit 1)
  206.                ((mod 4) 2)
  207.                ((mod 16) 4)
  208.                ((mod 256) 8)
  209.                ((mod #x10000) 16)
  210.                ((mod #x100000000) 32))
  211.              :test #'subtypep))
  212.       (x-type-error pixarray 'pixarray)))
  213.  
  214.  
  215. ;;;-----------------------------------------------------------------------------
  216. ;;; GET-IMAGE
  217.  
  218. ;; Should this be exported?
  219. (defun visual-info (display visual-id)
  220.   (dolist (screen (display-roots display))
  221.     (dolist (vis (screen-depths screen))
  222.       (dolist (visual-info (cdr vis))
  223.     (when (= visual-id (visual-info-id visual-info))
  224.       (return-from visual-info visual-info)))))
  225.   (error "Visual info not found for id #x~x in display ~s" visual-id display))
  226.  
  227. (defun get-image (drawable &key 
  228.           (x (required-arg x))
  229.           (y (required-arg y))
  230.           (width (required-arg width))
  231.           (height (required-arg height))
  232.           plane-mask format result-type)
  233.   ;; Get an image from the server.
  234.   ;; Result-Type defaults from Format, image-z for :z-pixmap, image-xy
  235.   ;; for :xy-pixmap and image-x when unspecified.
  236.   ;; Format defaults from result-type: :sy-pixmap for imagexy, :z-pixmap
  237.   ;; for image-z, or when unspecified.
  238.   ;; Plane-mask defaults to #xFFFFFFFF.
  239.   ;; Returns an image-x image-xy or image-z structure, depending on the
  240.   ;; result-type parameter.
  241.   (declare (type drawable drawable)
  242.        (type int16 x y) ;; required
  243.        (type card16 width height) ;; required
  244.        (type (or null pixel) plane-mask)
  245.        (type (or null (member :xy-pixmap :z-pixmap)) format)
  246.        (type (or null (member image-x image-xy image-z)) result-type))
  247.   (declare-values image visual-id)
  248.   (unless result-type
  249.     (setq result-type (case format
  250.             (:xy-pixmap 'image-xy)
  251.             (:z-pixmap 'image-z)
  252.             ((nil) 'image-x))))
  253.   (unless format
  254.     (setq format (case result-type
  255.            (image-xy :xy-pixmap)
  256.            ((image-z image-x) :z-pixmap))))
  257.   (unless (ecase result-type
  258.         (image-xy (eq format :xy-pixmap))
  259.         (image-z (eq format :z-pixmap))
  260.         (image-x t))
  261.     (error "Result-type ~s is incompatable with format ~s"
  262.        result-type format))
  263.   (multiple-value-bind (data depth visual-id)
  264.       (get-raw-image drawable :x x :y y :width width :height height
  265.              :plane-mask (or plane-mask #xffffffff) :format format)
  266.     (let* ((display (drawable-display drawable))
  267.        (bitmap-format (display-bitmap-format display))
  268.        (scanline-pad (bitmap-format-pad bitmap-format))
  269.        (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))
  270.        (byte-lsb-first-p (display-image-lsb-first-p display))
  271.        (bits-per-pixel depth)
  272.        (bytes-per-line 0))
  273.       (if (= depth 1)
  274.       (setq format :xy-pixmap)
  275.     (let ((pixmap-format (find depth (display-pixmap-formats display)
  276.                    :key #'pixmap-format-depth)))
  277.       (unless pixmap-format ;; Should never happen
  278.         (error "Display doesn't support pixmaps of depth ~d" depth))
  279.       (setq bits-per-pixel (pixmap-format-bits-per-pixel pixmap-format))
  280.       (when (eq format :z-pixmap)
  281.         (setq scanline-pad (pixmap-format-scanline-pad pixmap-format)))))
  282.       (if (eq format :z-pixmap)
  283.       (let ((scanline-length (ceiling (* width depth) 8)))
  284.         (setq bytes-per-line (scanline-byte-round scanline-length scanline-pad)))
  285.     (let ((scanline-length (ceiling width 8)))
  286.       (setq bytes-per-line (scanline-byte-round scanline-length scanline-pad))))
  287.       ;; Convert image to the format needed for pixarray transformation
  288.       (unless (eq result-type 'image-x)
  289.     (when byte-lsb-first-p
  290.       (byte-swap-vector data 0 (length data) scanline-pad))
  291.     (when (and bit-lsb-first-p (= depth 1))
  292.       (bit-reverse-vector data 0 (length data))))
  293.       (let ((image
  294.           (ecase result-type
  295.         (image-x
  296.          (create-image :width width :height height :format format
  297.                    :depth depth :data data
  298.                    :bits-per-pixel bits-per-pixel
  299.                    :bytes-per-line bytes-per-line
  300.                    :byte-lsb-first-p byte-lsb-first-p
  301.                    :bit-lsb-first-p bit-lsb-first-p
  302.                    ))
  303.         (image-xy
  304.          (do ((plane 0 (1+ plane))
  305.               (bytes-per-plane (* bytes-per-line height))
  306.               (start 0 (+ start bytes-per-plane))
  307.               (result nil))
  308.              ((>= plane depth)
  309.               (create-image :width width :height height
  310.                     :depth depth :data (nreverse result)
  311.                     ))
  312.            (push (z-format-pixarray data start bytes-per-line 1 1
  313.                         0 0 width height)
  314.              result)))
  315.         (image-z
  316.          (let ((pixarray (z-format-pixarray data 0 bytes-per-line depth bits-per-pixel
  317.                             0 0 width height)))
  318.            (create-image :width width :height height
  319.                  :depth depth :data pixarray
  320.                  ))))))
  321.     (when (plusp visual-id)
  322.       (let ((visual-info (visual-info display visual-id)))
  323.         (setf (image-red-mask image) (visual-info-red-mask visual-info))
  324.         (setf (image-green-mask image) (visual-info-green-mask visual-info))
  325.         (setf (image-blue-mask image) (visual-info-blue-mask visual-info))))
  326.     (values image visual-id)))))
  327.  
  328.  
  329. ;;;-----------------------------------------------------------------------------
  330. ;;; Pixel-Array conversions
  331.  
  332. #+comment ;; Used to generate the table in byte-reverse
  333. (defun genbyte ()
  334.   (let ((result (make-array 256)))
  335.     (dotimes (i 256)
  336.       (let ((b 0))
  337.     (setq b (dpb (ldb (byte 1 0) i) (byte 1 7) b))
  338.     (setq b (dpb (ldb (byte 1 1) i) (byte 1 6) b))
  339.     (setq b (dpb (ldb (byte 1 2) i) (byte 1 5) b))
  340.     (setq b (dpb (ldb (byte 1 3) i) (byte 1 4) b))
  341.     (setq b (dpb (ldb (byte 1 4) i) (byte 1 3) b))
  342.     (setq b (dpb (ldb (byte 1 5) i) (byte 1 2) b))
  343.     (setq b (dpb (ldb (byte 1 6) i) (byte 1 1) b))
  344.     (setq b (dpb (ldb (byte 1 7) i) (byte 1 0) b))
  345.     (setf (aref result i) b)))
  346.     result))
  347.  
  348. (proclaim '(inline byte-reverse))
  349. (defun byte-reverse (byte)
  350.   (aref '#.(coerce
  351.         '#(0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
  352.            8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
  353.            4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
  354.            12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
  355.            2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
  356.            10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
  357.            6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
  358.            14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
  359.            1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
  360.            9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
  361.            5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
  362.            13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
  363.            3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
  364.            11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
  365.            7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
  366.            15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
  367.          '(vector card8))
  368.     byte))
  369.  
  370.  
  371. (defun z-format-pixarray (data index bytes-per-line depth bits-per-pixel
  372.                 src-x src-y width height)
  373.   (declare (type (simple-array card8 (*)) data)
  374.        (type array-index index)
  375.        (type card16 bytes-per-line)
  376.        (type card8 depth)
  377.        (type (member 1 4 8 16 24 32) bits-per-pixel)
  378.        (type card16 src-x src-y width height))
  379.   (let* ((row src-y)
  380.      (copy-pixarray-row (cdr (assoc bits-per-pixel
  381.                     '((1 . z-format-row-1)
  382.                       (4 . z-format-row-4)
  383.                       (8 . z-format-row-8)
  384.                       (16 . z-format-row-16)
  385.                       (24 . z-format-row-24)
  386.                       (32 . z-format-row-32)))))
  387.      (pixarray (make-array (list height width) :element-type `(unsigned-byte ,depth))))
  388.     (declare (type array-index row)
  389.          (type pixarray pixarray))
  390.     (dotimes (i height)
  391.       ;; Copy scanline
  392.       (funcall copy-pixarray-row data index pixarray row src-x width)
  393.       (index-incf row)
  394.       (index-incf index bytes-per-line))
  395.     pixarray))
  396.  
  397. (defun z-format-row-1 (data index pixarray row src-x width)
  398.   ;; Copy 1 bit-per-pixel pixels from data to pixarray
  399.   (declare (type (simple-array card8 (*)) data)
  400.        (type array-index index row src-x width)
  401.        (type pixarray pixarray))
  402.   (with-vector (data (simple-array card8 (*)))
  403.     (let* ((col 0)
  404.        (index (+ index (ash src-x -3))) ;; starting index
  405.        (start-pixels (logand src-x 7))
  406.        (middle-bytes (ash (- width start-pixels) -3))
  407.        (end-pixels (- width start-pixels (ash middle-bytes 3))))
  408.       (declare (type array-index col index start-pixels middle-bytes end-pixels))
  409.       ;; copy partial byte at start
  410.       (when (plusp start-pixels)
  411.     (let ((byte (byte-reverse (aref data index))))
  412.       (declare (type card8 byte))
  413.       (index-incf index)
  414.       (dotimes (i start-pixels)
  415.         (setf (aref pixarray row i) (logand byte 1))
  416.         (setq byte (ash byte -1)))
  417.       (index-incf col start-pixels)))
  418.       ;; Copy whole bytes in middle
  419.       (dotimes (b middle-bytes)
  420.     (let ((byte (byte-reverse (aref data index))))
  421.       (declare (type card8 byte))
  422.       (index-incf index)
  423.       (setf (aref pixarray row col) (logand byte 1))
  424.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  425.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  426.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  427.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  428.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  429.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  430.       (setf (aref pixarray row (incf col)) (logand (setq byte (ash byte -1)) 1))
  431.       (incf col)))
  432.       ;; Copy partial byte at end
  433.       (when (plusp end-pixels)
  434.     (let ((byte (byte-reverse (aref data index))))
  435.       (declare (type card8 byte))
  436.       (index-incf index)
  437.       (dotimes (i end-pixels)
  438.         (setf (aref pixarray row (+ i col)) (logand byte 1))
  439.         (setq byte (ash byte -1))))))))
  440.  
  441. (defun z-format-row-4 (data index pixarray row src-x width)
  442.   ;; Copy 1 bit-per-pixel pixels from data to pixarray
  443.   (declare (type (simple-array card8 (*)) data)
  444.        (type array-index index row src-x width)
  445.        (type pixarray pixarray))
  446.   (with-vector (data (simple-array card8 (*)))
  447.     (let* ((col 0)
  448.        (index (+ index (ash src-x -1))) ;; starting index
  449.        (start-pixels (logand src-x 1))
  450.        (middle-bytes (ash (- width start-pixels) -1))
  451.        (end-pixels (- width start-pixels (ash middle-bytes 1))))
  452.       (declare (type array-index col index start-pixels middle-bytes end-pixels))
  453.       ;; copy partial byte at start
  454.       (when (plusp start-pixels)
  455.     (let ((byte (aref data index)))
  456.       (declare (type card8 byte))
  457.       (index-incf index)
  458.       (setf (aref pixarray row col) (logand byte 15))
  459.       (index-incf col)))
  460.       ;; Copy whole bytes in middle
  461.       (dotimes (b middle-bytes)
  462.     (let ((byte (aref data index)))
  463.       (declare (type card8 byte))
  464.       (index-incf index)
  465.       (setf (aref pixarray row col) (ash byte -4))
  466.       (setf (aref pixarray row (incf col)) (logand byte 15))
  467.       (incf col)))
  468.       ;; Copy partial byte at end
  469.       (when (plusp end-pixels)
  470.     (let ((byte (aref data index)))
  471.       (declare (type card8 byte))
  472.       (index-incf index)
  473.       (setf (aref pixarray row col) (ash byte -4)))))))
  474.  
  475. (defun z-format-row-8 (data index pixarray row src-x width)
  476.   ;; Copy 1 bit-per-pixel pixels from data to pixarray
  477.   (declare (type (simple-array card8 (*)) data)
  478.        (type array-index index row src-x width)
  479.        (type pixarray pixarray))
  480.   (with-vector (data (simple-array card8 (*)))
  481.     (let* ((index (+ index src-x))) ;; starting index
  482.       (declare (type array-index index))
  483.       (dotimes (col width)
  484.     (setf (aref pixarray row col) (aref data index))
  485.     (index-incf index)))))
  486.  
  487. (defun z-format-row-16 (data index pixarray row src-x width)
  488.   ;; Copy 1 bit-per-pixel pixels from data to pixarray
  489.   (declare (type (simple-array card8 (*)) data)
  490.        (type array-index index row src-x width)
  491.        (type pixarray pixarray))
  492.   (with-vector (data (simple-array card8 (*)))
  493.     (let* ((index (+ index src-x))) ;; starting index
  494.       (declare (type array-index index))
  495.       (dotimes (col width)
  496.     (setf (aref pixarray row col)
  497.           (dpb (aref data index) (byte 8 8) (aref data (index-incf index))))
  498.     (index-incf index)))))
  499.  
  500. (defun z-format-row-24 (data index pixarray row src-x width)
  501.   ;; Copy 1 bit-per-pixel pixels from data to pixarray
  502.   (declare (type (simple-array card8 (*)) data)
  503.        (type array-index index row src-x width)
  504.        (type pixarray pixarray))
  505.   (with-vector (data (simple-array card8 (*)))
  506.     (let* ((index (+ index src-x))) ;; starting index
  507.       (declare (type array-index index))
  508.       (dotimes (col width)
  509.     (setf (aref pixarray row col)
  510.           (dpb (aref data index) (byte 8 16)
  511.            (dpb (aref data (index-incf index)) (byte 8 8)
  512.             (aref data (index-incf index)))))
  513.     (index-incf index)))))
  514.  
  515. (defun z-format-row-32 (data index pixarray row src-x width)
  516.   ;; Copy 1 bit-per-pixel pixels from data to pixarray
  517.   (declare (type (simple-array card8 (*)) data)
  518.        (type array-index index row src-x width)
  519.        (type pixarray pixarray))
  520.   (with-vector (data (simple-array card8 (*)))
  521.     (let* ((index (+ index src-x))) ;; starting index
  522.       (declare (type array-index index))
  523.       (dotimes (col width)
  524.     (setf (aref pixarray row col)
  525.           (dpb (aref data index) (byte 8 24)
  526.            (dpb (aref data (index-incf index)) (byte 8 16)
  527.             (dpb (aref data (index-incf index)) (byte 8 8)
  528.                  (aref data (index-incf index))))))
  529.     (index-incf index)))))
  530.  
  531. #+comment ;; not used
  532. (defun xy-format-image-pixarray (data index width height depth bytes-per-line)
  533.   ;; Extract a pixarray from an xy-pixmap data vector
  534.   (declare (type card16 height depth bytes-per-line))
  535.   (let* ((end-byte (floor width 8))
  536.      (right-pad (rem width 8))
  537.      (width8 end-byte)
  538.      (plane-length (* height bytes-per-line))
  539.      (pixarray (make-array (list height width) :element-type `(unsigned-byte ,depth)))
  540.      (plane-start 0)
  541.      (start index)
  542.      (nbyte 0)
  543.      (col 0))
  544.     (declare (type card16 end-byte right-pad width8)
  545.          (type array-index start plane-length plane-start nbyte col))
  546.     (with-vector (data (simple-array card8 (*)))
  547.       (do ((shift 0 (1+ shift))
  548.        (mask 1 (ash mask 1)))
  549.       ((>= shift depth))
  550.     (declare (type card16 shift mask))
  551.     (dotimes (row height pixarray)
  552.       (setq col 0)
  553.       ;; Copy full bytes in center
  554.       (dotimes (i width8)
  555.         (do ((sbit 0 (1+ sbit))
  556.          (byte (ash (byte-reverse (aref data nbyte)) shift)
  557.                (ash byte -1))) ;; Reverse to make shifting easier
  558.         ((>= sbit 8))
  559.           (declare (type card16 sbit byte))
  560.           (setf (aref pixarray row col)
  561.             (logior (aref pixarray row col) (logand mask byte)))
  562.           (incf col))
  563.         (incf nbyte))
  564.       ;; Copy partial byte at end
  565.       (when (plusp right-pad)
  566.         (do ((sbit 0 (1+ sbit))
  567.          (byte (ash (byte-reverse (aref data nbyte)) shift)
  568.                (ash byte -1))) ;; Reverse to make shifting easier
  569.         ((>= sbit right-pad))
  570.           (declare (type card16 sbit byte))
  571.           (setf (aref pixarray row col)
  572.             (logior (aref pixarray row col) (logand mask byte)))
  573.           (incf col)))
  574.       (incf start bytes-per-line)
  575.       (setq nbyte start))
  576.     (incf plane-start plane-length)
  577.     (setq start plane-start))
  578.       pixarray)))
  579.  
  580. ;; Before an image can be byte-swapped, each scanline must be padded
  581. ;; out to a multiple of the scanline pad.
  582. (defun convert-image-scanline-pad (image scanline-pad)
  583.   (declare (type image-x image)
  584.        (type (member 8 16 32) scanline-pad))
  585.   (let* ((width (image-width image))
  586.      (height (image-height image))
  587.      (data (image-x-data image))
  588.      (depth (image-depth image))
  589.      (scanline-length (ceiling (* width depth) 8))
  590.      (image-length (scanline-byte-round scanline-length scanline-pad))
  591.      (pad (- image-length scanline-length))
  592.      (sbyte 0)
  593.      (dbyte 0))
  594.     (unless (zerop pad)
  595.       (with-vector (data (simple-array card8 (*)))
  596.     (let* ((length (* image-length height))
  597.            (result (if (<= length (length data)) data
  598.              (make-array length :element-type '(unsigned-byte 8)))))
  599.       (with-vector (result (simple-array card8 (*)))
  600.         (setf (image-x-data image) result)
  601.         (dotimes (i height)
  602.           (dotimes (j scanline-length)
  603.         (setf (aref result dbyte) (aref data sbyte))
  604.         (incf dbyte)
  605.         (incf sbyte))
  606.           (incf dbyte pad))))))))
  607.  
  608. (defun byte-swap-image (image scanline-pad)
  609.   ;; Swap bytes
  610.   (declare (type image-x image))
  611.   (let ((data (image-x-data image)))
  612.     (setf (image-x-byte-lsb-first-p image) (not (image-x-byte-lsb-first-p image)))
  613.     (byte-swap-vector data 0 (length data) scanline-pad)))
  614.  
  615. (defun byte-swap-vector (data start nbytes scanline-pad)
  616.   (let ((sbyte start)
  617.     (dbyte start))
  618.     (with-vector (data (simple-array card8 (*)))
  619.       (ecase scanline-pad
  620.     (8 nil) ;; Nothing to swap
  621.     (16                    ; Swap 2 bytes
  622.      (dotimes (j (floor nbytes 2))
  623.        (let ((temp (aref (aref data sbyte))))
  624.          (setf (aref data dbyte) (aref data (incf sbyte)))
  625.          (setf (aref data (incf dbyte)) temp))
  626.        (incf dbyte)
  627.        (incf sbyte)))
  628.     (24                    ; Swap 3 bytes
  629.      (dotimes (j (floor nbytes 3))
  630.        (let ((temp1 (aref (aref data sbyte)))
  631.          (temp2 (aref data (incf sbyte))))
  632.          (setf (aref data dbyte) (aref data (incf sbyte)))
  633.          (setf (aref data (incf dbyte)) temp2)
  634.          (setf (aref data (incf dbyte)) temp1))
  635.        (incf dbyte)
  636.        (incf sbyte)))
  637.     (32                    ; Swap word
  638.      (dotimes (j (floor nbytes 4))
  639.        (let ((temp1 (aref data sbyte))
  640.          (temp2 (aref data (incf sbyte)))
  641.          (temp3 (aref data (incf sbyte))))
  642.          (setf (aref data dbyte) (aref data (incf sbyte)))
  643.          (setf (aref data (incf dbyte)) temp3)
  644.          (setf (aref data (incf dbyte)) temp2)
  645.          (setf (aref data (incf dbyte)) temp1))
  646.        (incf dbyte)
  647.        (incf sbyte)))))
  648.     sbyte))
  649.  
  650. (defun bit-reverse-image (image)
  651.   (let ((data (image-x-data image)))
  652.     (bit-reverse-vector data 0 (length data)))
  653.   (setf (image-x-bit-lsb-first-p image)
  654.     (not (image-x-bit-lsb-first-p image))))
  655.  
  656. (defun bit-reverse-vector (data start nbytes)
  657.   (declare (type (simple-array card8 (*)) data)
  658.        (type array-index start nbytes))
  659.   (let* ((index start))
  660.     (declare (type array-index index))
  661.     (with-vector (data (simple-array card8 (*)))
  662.       (dotimes (i nbytes)
  663.     (setf (aref data index) (byte-reverse (aref data index)))
  664.     (index-incf index)))))
  665.  
  666.  
  667.  
  668. ;;;-----------------------------------------------------------------------------
  669. ;;; PUT-IMAGE
  670.  
  671. ;;; Note:    The only difference between a format of :bitmap and :xy-pixmap
  672. ;;;        of depth 1 is that when sending a :bitmap format the foreground 
  673. ;;;        and background in the gcontext are used.
  674.  
  675. (defun put-image (drawable gcontext image &rest options &key
  676.           (src-x 0) (src-y 0)        ;Position within image
  677.           (x (required-arg x))        ;Position within drawable
  678.           (y (required-arg y))
  679.           width height
  680.           bitmap-p)
  681.   ;; Copy an image into a drawable.
  682.   ;; WIDTH and HEIGHT default from IMAGE.
  683.   ;; When BITMAP-P, force format to be :bitmap when depth=1.
  684.   ;; This causes gcontext to supply foreground & background pixels.
  685.   (declare (type drawable drawable)
  686.        (type gcontext gcontext)
  687.        (type image image)
  688.        (type int16 x y) ;; required
  689.        (type (or null card16) width height)
  690.        (type boolean bitmap-p))
  691.   (let* ((image-width (image-width image))
  692.      (image-height (image-height image))
  693.      (width (min (or width image-width) (- image-width src-x)))
  694.      (height (min (or height image-height) (- image-height src-y)))
  695.      (depth (image-depth image))
  696.      (display (drawable-display drawable))
  697.      (bitmap-format (display-bitmap-format display))
  698.      (scanline-pad (bitmap-format-pad bitmap-format))
  699.      pixmap-format)
  700.     (declare (type card16 image-width image-height width height depth scanline-pad))
  701.       (if bitmap-p
  702.       (unless (= depth 1) (error "Bitmaps must have depth 1"))
  703.     (progn
  704.       (setq pixmap-format (find depth (display-pixmap-formats display)
  705.                     :key #'pixmap-format-depth))
  706.       (unless pixmap-format
  707.         (error "Display doesn't support pixmaps of depth ~d" depth))))
  708.     (etypecase image
  709.       (image-x
  710.        (when (eq (image-x-format image) :z-pixmap)
  711.      (setq scanline-pad (pixmap-format-scanline-pad pixmap-format)))
  712.        (put-image-x drawable gcontext image src-x src-y x y width height bitmap-p scanline-pad))
  713.       (image-xy (put-image-xy drawable gcontext image src-x src-y x y width height bitmap-p scanline-pad))
  714.       (image-z
  715.        (when pixmap-format
  716.      (setq scanline-pad (pixmap-format-scanline-pad pixmap-format)))
  717.        (put-image-z drawable gcontext image src-x src-y x y width height bitmap-p scanline-pad)))))
  718. ;;
  719. ;; PUT X-IMAGE
  720. ;;
  721. (defun put-image-x (drawable gcontext image src-x src-y x y width height bitmap-p scanline-pad)
  722.   ;; Send an X-Format image to the server
  723.   ;; When BITMAP-P, force format to be :bitmap when depth=1
  724.   ;; This causes gcontext to supply foreground & background pixels.
  725.   (declare (type drawable drawable)
  726.        (type gcontext gcontext)
  727.        (type image-x image)
  728.        (type card16 src-x src-y)
  729.        (type int16 x y)
  730.        (type card16 width height)
  731.        (type boolean bitmap-p))
  732.   (let* ((display (drawable-display drawable))
  733.      (format (image-x-format image))
  734.      (depth (image-depth image))
  735.      (bitmap-format (display-bitmap-format display))
  736.      (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))
  737.      (byte-lsb-first-p (display-image-lsb-first-p display)))
  738.     (when bitmap-p
  739.       (setq format :bitmap))
  740.     ;; Convert image to the format needed by the display
  741.     (when (not (eq (and byte-lsb-first-p t) (and (image-x-byte-lsb-first-p image) t)))
  742.       (unless (zerop (rem (image-x-bytes-per-line image) (floor scanline-pad 8)))
  743.     (convert-image-scanline-pad image scanline-pad))
  744.       (byte-swap-image image scanline-pad))
  745.     (when (and (= depth 1)
  746.            (not (eq (and bit-lsb-first-p t) (and (image-x-bit-lsb-first-p image) t))))
  747.       (bit-reverse-image image))
  748.     (put-image-x-internal drawable gcontext image src-x src-y x y width height format scanline-pad)))
  749.  
  750. (defun put-image-x-internal (drawable gcontext image src-x src-y x y width height format scanline-pad)
  751.   ;; Send an X-Format image to the server after all image conversion has been done.
  752.   (declare (type drawable drawable)
  753.        (type gcontext gcontext)
  754.        (type image-x image)
  755.        (type int16 x y) ;; required
  756.        (type card16 src-x src-y)
  757.        (type card16 width height)
  758.        (type (member :bitmap :xy-pixmap :z-pixmap) format)
  759.        (type (member 8 16 32) scanline-pad))
  760.   ;; Geometry calculations      
  761.   (let* ((display (drawable-display drawable))
  762.      (depth (image-depth image)))
  763.     (declare (type display display)
  764.          (type card8 depth))
  765.     ;; Send image to the display
  766.     (with-buffer-request (display *x-putimage* :gc-force gcontext)
  767.       ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
  768.       (drawable drawable)
  769.       (gcontext gcontext)
  770.       (card16 width height)
  771.       (int16 x y)
  772.       (card8 0 depth)                ;left-pad, depth
  773.       (pad16 nil)
  774.       (progn ;; Need seperate copy functions for XY and Z formats, because
  775.          ;; the sub-image extraction has to work differently.
  776.     (if (eq format :z-pixmap)
  777.         (buffer-put-image display buffer-boffset image src-x src-y width height
  778.                   scanline-pad (image-x-bits-per-pixel image) 1)
  779.       (buffer-put-image display buffer-boffset image src-x src-y width height
  780.                 scanline-pad 1 depth))))))
  781.  
  782. (defun buffer-put-image (buffer boffset image src-x src-y width height scanline-pad bits-per-pixel nplanes)
  783.   ;; copy an X-Format Z-pixmap image into the buffer
  784.   (declare (type buffer buffer)
  785.        (type array-index boffset)
  786.        (type image-x image)
  787.        (type card16 src-x src-y width height)
  788.        (type (member 8 16 32) scanline-pad)
  789.        (type (member 1 4 8 16 24 32) bits-per-pixel)
  790.        (type card8 nplanes))
  791.   (let* ((start-bit (* src-x bits-per-pixel))
  792.      (start-byte (floor start-bit 8))
  793.      (end-byte (ceiling (+ start-bit (* width bits-per-pixel)) 8))
  794.      (scanline-length (scanline-byte-round (- end-byte start-byte) scanline-pad))
  795.      (length (* height scanline-length nplanes))
  796.      (size (buffer-size buffer))
  797.      (data (image-x-data image))
  798.      (image-x-bytes-per-line (image-x-bytes-per-line image))
  799.      (start (* src-y image-x-bytes-per-line))
  800.      (plane-length (+ (* (image-height image) image-x-bytes-per-line) start))
  801.      (plane-start start))
  802.     (declare (type array-index start-bit start-byte end-byte scanline-length length
  803.            size image-x-bytes-per-line start)
  804.          (type (simple-array card8 (*)) data))
  805.     (with-buffer-output (buffer :index boffset :sizes (8 16))
  806.       (card16-put 2 (ceiling (+ 24 length) 4)) ;; Set length
  807.       (incf boffset 24)
  808.       ;; Note: The server doesn't handle left-pad for z-format, and neither do we.
  809.       (dotimes (i nplanes)
  810.     (setq start plane-start)
  811.     (do ((nrows 0)
  812.          (rows height (- rows nrows)))
  813.         ((not (plusp rows)))
  814.       (declare (type fixnum nrows rows))
  815.       (setq nrows (floor (- size boffset) scanline-length))
  816.       (when (zerop nrows)
  817.         ;; Flush buffer when necessary
  818.         (setf (buffer-boffset buffer) boffset)
  819.         (buffer-flush buffer)
  820.         (setq boffset (buffer-boffset buffer))
  821.         (setq nrows (floor (- size boffset) scanline-length)))      
  822.       ;; Copy scanlines
  823.       (dotimes (r (min rows nrows))
  824.         (buffer-replace buffer-bbuf data boffset (incf boffset scanline-length)
  825.                 (+ start start-byte))
  826.         (incf start image-x-bytes-per-line)))
  827.     (incf plane-start plane-length))
  828.       (setf (buffer-boffset buffer) (lround boffset)))))
  829. ;;
  830. ;; PUT Z-IMAGE
  831. ;;
  832. (defun put-image-z (drawable gcontext image src-x src-y x y width height bitmap-p scanline-pad)
  833.   ;; Send a Z-Format image to the server
  834.   ;; When BITMAP-P, force format to be :bitmap when depth=1
  835.   ;; This causes gcontext to supply foreground & background pixels.
  836.   (declare (type drawable drawable)
  837.        (type gcontext gcontext)
  838.        (type image-z image)
  839.        (type card16 src-x src-y)
  840.        (type int16 x y)
  841.        (type card16 width height)
  842.        (type boolean bitmap-p))
  843.   ;; Geometry calculations      
  844.   (let* ((display (drawable-display drawable))
  845.      (depth (image-z-bits-per-pixel image))
  846.      (image-width (image-width image))
  847.      (image-height (image-height image))
  848.      (width (min (or width image-width) (- image-width src-x)))
  849.      (height (min (or height image-height) (- image-height src-y)))
  850.      (format :z-pixmap)
  851.      (pixarray (image-z-pixarray image))
  852.      (bits-per-pixel (image-z-bits-per-pixel image)))
  853.     (declare (type display display)
  854.          (type card8 depth)
  855.          (type card16 image-width image-height width height)
  856.          (type pixarray pixarray)
  857.          (type (member 1 4 8 16 24 32) bits-per-pixel))
  858.     (when bitmap-p
  859.       (setq format :bitmap)
  860.       (unless (= depth 1) (error "Bitmaps must have depth 1")))
  861.     ;; Send image to the display
  862.     (with-buffer-request (display *x-putimage* :gc-force gcontext)
  863.       ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
  864.       (drawable drawable)
  865.       (gcontext gcontext)
  866.       (card16 width height)
  867.       (int16 x y)
  868.       (card8 0 depth)                ;left-pad, depth
  869.       (pad16 nil)
  870.       (progn
  871.     (buffer-put-pixarray display buffer-boffset pixarray bits-per-pixel src-x src-y width height scanline-pad)))))
  872.  
  873. (defun buffer-put-pixarray (display boffset pixarray bits-per-pixel src-x src-y width height scanline-pad)
  874.   (declare (type display display)
  875.        (type array-index boffset)
  876.        (type pixarray pixarray)
  877.        (type (member 1 4 8 16 24 32) bits-per-pixel)
  878.        (type card16 src-x src-y width height))
  879.   (let* ((row src-y)
  880.      (copy-pixarray-row (cdr (assoc bits-per-pixel
  881.                     '((1 . copy-pixarray-row-1)
  882.                       (4 . copy-pixarray-row-4)
  883.                       (8 . copy-pixarray-row-8)
  884.                       (16 . copy-pixarray-row-16)
  885.                       (24 . copy-pixarray-row-24)
  886.                       (32 . copy-pixarray-row-32)))))
  887.      (bytes-per-line (ceiling (* width bits-per-pixel) 8))
  888.      (scanline-length (scanline-byte-round bytes-per-line scanline-pad))
  889.      (length (* height scanline-length))
  890.      (size (buffer-size display))
  891.      (bitmap-format (display-bitmap-format display))
  892.      (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))
  893.      (byte-lsb-first-p (display-image-lsb-first-p display)))
  894.     (declare (type array-index row bytes-per-line scanline-length length size))
  895.     (with-buffer-output (display :index boffset :sizes (8 16))
  896.       (card16-put 2 (ceiling (index+ 24 length) 4)) ;; Set length
  897.       (index-incf boffset 24)
  898.       (dotimes (i height)
  899.     ;; Flush buffer when necessary
  900.     (when (>= (+ boffset scanline-length) size)
  901.       (setf (buffer-boffset display) boffset)
  902.       (buffer-flush display)
  903.       (setq boffset (buffer-boffset display)))
  904.     ;; Copy scanline
  905.     (funcall copy-pixarray-row buffer-bbuf boffset pixarray row src-x width)
  906.     ;; Swap bytes and bits when needed
  907.     (ecase bits-per-pixel
  908.       ((1)
  909.        (when bit-lsb-first-p
  910.          (bit-reverse-vector buffer-bbuf boffset scanline-length)))
  911.       ((4)
  912.        (when byte-lsb-first-p
  913.          (error "Need to swap the nibbles.")))
  914.       ((8))
  915.       ((16 24 32)
  916.        (when byte-lsb-first-p
  917.          (byte-swap-vector buffer-bbuf boffset scanline-length bits-per-pixel))))
  918.     (index-incf row)
  919.     (index-incf boffset scanline-length))
  920.       (setf (buffer-boffset display) (lround boffset)))))
  921.  
  922. (defun copy-pixarray-row-1 (buffer index pixarray row src-x width)
  923.   ;; Copy a row of 1 bit-per-pixel pixels from from PIXARRAY to BUFFER
  924.   (declare (type (simple-array card8 (*)) buffer)
  925.        (type array-index index row src-x width)
  926.        (type pixarray pixarray))
  927.   (with-vector (buffer (simple-array card8 (*)))
  928.     (let ((x (index- src-x 1))
  929.       (index index)
  930.       (end-bits (logand width 7))) ;; (REM width 8)
  931.       (declare (type array-index x index end-bits))
  932.       (dotimes (i (ash width -3)) ;; (FLOOR width 8)
  933.     (setf (aref buffer index)
  934.           (logior (ash (aref pixarray row (index-incf x)) 7)
  935.               (ash (aref pixarray row (index-incf x)) 6)
  936.               (ash (aref pixarray row (index-incf x)) 5)
  937.               (ash (aref pixarray row (index-incf x)) 4)
  938.               (ash (aref pixarray row (index-incf x)) 3)
  939.               (ash (aref pixarray row (index-incf x)) 2)
  940.               (ash (aref pixarray row (index-incf x)) 1)
  941.               (aref pixarray row (index-incf x))))
  942.     (index-incf index))
  943.       (when (plusp end-bits)
  944.     (let ((byte 0))
  945.       (declare (type card8 byte))
  946.       (dotimes (i end-bits)
  947.         (setq byte (logior (ash byte 1) (aref pixarray row (index-incf x)))))
  948.       (setf (aref buffer index) (ash byte (- 8 end-bits))))))))
  949.  
  950. (defun copy-pixarray-row-4 (buffer index pixarray row src-x width)
  951.   ;; Copy a row of 4 bit-per-pixel pixels from from PIXARRAY to BUFFER
  952.   (declare (type (simple-array card8 (*)) buffer)
  953.        (type array-index index row src-x width)
  954.        (type pixarray pixarray))
  955.   (with-vector (buffer (simple-array card8 (*)))
  956.     (let ((x (index- src-x 1))
  957.       (index index))
  958.       (declare (type array-index x index))
  959.       (dotimes (i (ash width -1)) ;; (FLOOR width 2)
  960.     (setf (aref buffer index)
  961.           (logior (ash (aref pixarray row (index-incf x)) 4)
  962.               (aref pixarray row (index-incf x))))
  963.     (index-incf index))
  964.       (when (oddp width)
  965.     (setf (aref buffer index) (ash (aref pixarray row (index-incf x)) 4))))))
  966.  
  967. (defun copy-pixarray-row-8 (buffer index pixarray row src-x width)
  968.   ;; Copy a row of 8 bit-per-pixel pixels from from PIXARRAY to BUFFER
  969.   (declare (type (simple-array card8 (*)) buffer)
  970.        (type array-index index row src-x width)
  971.        (type pixarray pixarray))
  972.   (with-vector (buffer (simple-array card8 (*)))
  973.     (let ((x (index- src-x 1))
  974.       (index index))
  975.       (declare (type array-index x index))
  976.       (dotimes (i width)
  977.     (setf (aref buffer index)
  978.           (aref pixarray row (index-incf x)))
  979.     (index-incf index)))))
  980.  
  981. (defun copy-pixarray-row-16 (buffer index pixarray row src-x width)
  982.   ;; Copy a row of 16 bit-per-pixel pixels from from PIXARRAY to BUFFER
  983.   (declare (type (simple-array card8 (*)) buffer)
  984.        (type array-index index row src-x width)
  985.        (type pixarray pixarray))
  986.   (with-vector (buffer (simple-array card8 (*)))
  987.     (let ((x (index- src-x 1))
  988.       (index index))
  989.       (declare (type array-index x index))
  990.       (dotimes (i width)
  991.     (let ((pixel (aref pixarray row (index-incf x))))
  992.       (setf (aref buffer index) (ldb (byte 8 8) pixel))
  993.       (index-incf index)
  994.       (setf (aref buffer index) pixel)
  995.       (index-incf index))))))
  996.  
  997. (defun copy-pixarray-row-24 (buffer index pixarray row src-x width)
  998.   ;; Copy a row of 16 bit-per-pixel pixels from from PIXARRAY to BUFFER
  999.   (declare (type (simple-array card8 (*)) buffer)
  1000.        (type array-index index row src-x width)
  1001.        (type pixarray pixarray))
  1002.   (with-vector (buffer (simple-array card8 (*)))
  1003.     (let ((x (index- src-x 1))
  1004.       (index index))
  1005.       (declare (type array-index x index))
  1006.       (dotimes (i width)
  1007.     (let ((pixel (aref pixarray row (index-incf x))))
  1008.       (setf (aref buffer index) (ldb (byte 8 16) pixel))
  1009.       (index-incf index)
  1010.       (setf (aref buffer index) (ldb (byte 8 8) pixel))
  1011.       (index-incf index)
  1012.       (setf (aref buffer index) pixel)
  1013.       (index-incf index))))))
  1014.  
  1015. (defun copy-pixarray-row-32 (buffer index pixarray row src-x width)
  1016.   ;; Copy a row of 16 bit-per-pixel pixels from from PIXARRAY to BUFFER
  1017.   (declare (type (simple-array card8 (*)) buffer)
  1018.        (type array-index index row src-x width)
  1019.        (type pixarray pixarray))
  1020.   (with-vector (buffer (simple-array card8 (*)))
  1021.     (let ((x (index- src-x 1))
  1022.       (index index))
  1023.       (declare (type array-index x index))
  1024.       (dotimes (i width)
  1025.     (let ((pixel (aref pixarray row (index-incf x))))
  1026.       (setf (aref buffer index) (ldb (byte 8 24) pixel))
  1027.       (index-incf index)
  1028.       (setf (aref buffer index) (ldb (byte 8 16) pixel))
  1029.       (index-incf index)
  1030.       (setf (aref buffer index) (ldb (byte 8 8) pixel))
  1031.       (index-incf index)
  1032.       (setf (aref buffer index) pixel)
  1033.       (index-incf index))))))
  1034. ;;
  1035. ;; PUT XY-IMAGE
  1036. ;;
  1037. (defun put-image-xy (drawable gcontext image src-x src-y x y width height bitmap-p scanline-pad)
  1038.   ;; Send an XY-Format image to the server
  1039.   ;; When BITMAP-P, force format to be :bitmap when depth=1
  1040.   ;; This causes gcontext to supply foreground & background pixels.
  1041.   (declare (type drawable drawable)
  1042.        (type gcontext gcontext)
  1043.        (type image-xy image)
  1044.        (type card16 src-x src-y)
  1045.        (type int16 x y)
  1046.        (type card16 width height)
  1047.        (type boolean bitmap-p))
  1048.   ;; Geometry calculations      
  1049.   (let* ((display (drawable-display drawable))
  1050.      (depth (image-depth image))
  1051.      (image-width (image-width image))
  1052.      (image-height (image-height image))
  1053.      (width (min (or width image-width) (- image-width src-x)))
  1054.      (height (min (or height image-height) (- image-height src-y)))
  1055.      (format :xy-pixmap))
  1056.     (declare (type display display)
  1057.          (type card8 depth)
  1058.          (type card16 image-width image-height width height))
  1059.     (when bitmap-p
  1060.       (setq format :bitmap)
  1061.       (unless (= depth 1) (error "Bitmaps must have depth 1")))
  1062.     ;; Send image to the display
  1063.     (with-buffer-request (display *x-putimage* :gc-force gcontext)
  1064.       ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
  1065.       (drawable drawable)
  1066.       (gcontext gcontext)
  1067.       (card16 width height)
  1068.       (int16 x y)
  1069.       (card8 0 depth)                ;left-pad, depth
  1070.       (pad16 nil)
  1071.       (progn
  1072.     (buffer-put-xy-pixarray display buffer-boffset (image-xy-bitmap-list image)
  1073.                 1 src-x src-y width height scanline-pad)))))
  1074.  
  1075. (defun buffer-put-xy-pixarray (display boffset bitmaps bits-per-pixel src-x src-y width height scanline-pad)
  1076.   (declare (type display display)
  1077.        (type array-index boffset)
  1078.        (type list bitmaps)
  1079.        (type (member 1 4 8 16 24 32) bits-per-pixel)
  1080.        (type card16 src-x src-y width height))
  1081.   (let* ((row src-y)
  1082.      (bytes-per-line (ceiling (* width bits-per-pixel) 8))
  1083.      (bitmap-format (display-bitmap-format display))
  1084.      (scanline-length (scanline-byte-round bytes-per-line scanline-pad))
  1085.      (length (* height scanline-length (length bitmaps)))
  1086.      (size (buffer-size display))
  1087.      (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))
  1088.      (byte-lsb-first-p (display-image-lsb-first-p display)))
  1089.     (declare (type array-index row bytes-per-line scanline-length length size))
  1090.     (with-buffer-output (display :index boffset :sizes (8 16))
  1091.       (card16-put 2 (ceiling (index+ 24 length) 4)) ;; Set length
  1092.       (index-incf boffset 24)
  1093.       (dolist (pixarray bitmaps)
  1094.     (setq row src-y)
  1095.     (dotimes (i height)
  1096.       ;; Flush buffer when necessary
  1097.       (when (>= (+ boffset scanline-length) size)
  1098.         (setf (buffer-boffset display) boffset)
  1099.         (buffer-flush display)
  1100.         (setq boffset (buffer-boffset display)))
  1101.       ;; Copy scanline
  1102.       (copy-pixarray-row-1 buffer-bbuf boffset pixarray row src-x width)
  1103.       ;; Swap bytes and bits when needed
  1104.       (when byte-lsb-first-p
  1105.         (byte-swap-vector buffer-bbuf boffset scanline-length scanline-pad))
  1106.       (when (and (= bits-per-pixel 1) bit-lsb-first-p)
  1107.         (bit-reverse-vector buffer-bbuf boffset scanline-length))
  1108.       (index-incf row)
  1109.       (index-incf boffset scanline-length)))
  1110.       (setf (buffer-boffset display) (lround boffset)))))
  1111.  
  1112.  
  1113. ;;;-----------------------------------------------------------------------------
  1114.  
  1115. (defun copy-image (image &key (x 0) (y 0) width height result-type)
  1116.   ;; Copy with optional sub-imaging and format conversion.
  1117.   ;; result-type defaults to (type-of image)
  1118.   (declare (type image image)
  1119.        (type card16 x y)
  1120.        (type (or null card16) width height) ;; Default from image
  1121.        (type (or null (member image-x image-xy image-z)) result-type))
  1122.   (declare-values image)
  1123.   (let* ((image-width (image-width image))
  1124.      (image-height (image-height image))
  1125.      (width (or width image-width))
  1126.      (height (or height image-height)))
  1127.     (setq width (min width (max (- image-width x) 0)))
  1128.     (setq height (min height (max (- image-height x) 0)))
  1129.     (etypecase image
  1130.       (image-x
  1131.        (ecase result-type
  1132.      ((nil image-x) (image-x->image-x image x y width height))
  1133.      (image-xy (image-x->image-xy image x y width height))
  1134.      (image-z  (image-x->image-z  image x y width height))))
  1135.       (image-xy
  1136.        (ecase result-type
  1137.      (image-x (image-xy->image-x image x y width height))
  1138.      ((nil image-xy)
  1139.       (let ((copy (copy-image-xy image)))
  1140.         (setf (image-xy-bitmap-list copy)
  1141.           (mapcar #'copy-pixarray (image-xy-bitmap-list image)))
  1142.         copy))
  1143.      (image-z  (image-xy->image-z  image x y width height))))
  1144.       (image-z 
  1145.        (ecase result-type
  1146.      (image-x (image-z->image-x image x y width height))
  1147.      (image-xy  (image-z->image-xy image x y width height))
  1148.      ((nil image-z)
  1149.       (let ((copy (copy-image-z image)))
  1150.         (setf (image-z-pixarray copy) (copy-pixarray (image-z-pixarray image)))
  1151.         copy)))))))
  1152.  
  1153. (defun copy-pixarray (array)
  1154.   (if #.(fboundp 'copy) ;; Some lisps may not have copy...
  1155.       (copy array)
  1156.     (let ((copy (make-array (array-dimensions array)
  1157.                 :element-type (array-element-type array))))
  1158.       (dotimes (i (array-dimension array 0))
  1159.     (dotimes (j (array-dimension array 1))
  1160.       (setf (aref copy i j) (aref array i j))))
  1161.       copy)))
  1162.  
  1163. (defun image-x->image-x (image src-x src-y width height)
  1164.   (let ((vector
  1165.       (ecase (image-x-format image)
  1166.         (:z-pixmap
  1167.          (copy-image-to-vector image src-x src-y width height (image-x-bits-per-pixel image) 1))
  1168.         (:xy-pixmap
  1169.          (copy-image-to-vector image src-x src-y width height 1 (image-depth image))))))
  1170.     (create-image :width width :height height :plist (image-plist image)
  1171.           :depth (image-x-depth image)
  1172.           :data vector)))
  1173.  
  1174. (defun copy-image-to-vector (image src-x src-y width height bits-per-pixel nplanes)
  1175.   ;; copy an X-Format Z-pixmap image into the buffer
  1176.   (declare (type image-x image)
  1177.        (type card16 src-x src-y width height)
  1178.        (type (member 1 4 8 16 24 32) bits-per-pixel)
  1179.        (type card8 nplanes))
  1180.   (let* ((start-bit (* src-x bits-per-pixel))
  1181.      (start-byte (floor start-bit 8))
  1182.      (end-byte (ceiling (+ start-bit (* width bits-per-pixel)) 8))
  1183.      (scanline-length (- end-byte start-byte))
  1184.      (length (* height scanline-length nplanes))
  1185.      (vector (make-array length :element-type 'card8))
  1186.      (data (image-x-data image))
  1187.      (image-x-bytes-per-line (image-x-bytes-per-line image))
  1188.      (start (* src-y image-x-bytes-per-line))
  1189.      (plane-length (+ (* (image-height image) image-x-bytes-per-line) start))
  1190.      (plane-start start)
  1191.      (boffset 0))
  1192.     (declare (type array-index start-bit start-byte end-byte scanline-length length
  1193.            image-x-bytes-per-line start boffset)
  1194.          (type (simple-array card8 (*)) data))
  1195.     ;; Note: The server doesn't handle left-pad for z-format, and neither do we.
  1196.     (dotimes (i nplanes)
  1197.       (setq start plane-start)
  1198.       ;; Copy scanlines
  1199.       (dotimes (row height)
  1200.     (buffer-replace vector data boffset (incf boffset scanline-length)
  1201.             (+ start start-byte))
  1202.     (incf start image-x-bytes-per-line))
  1203.       (incf plane-start plane-length))
  1204.     vector))
  1205.  
  1206. (defun image-x->image-z  (image x y width height)
  1207.   (declare (type image-x image)
  1208.        (type card16 x y width height))
  1209.   (declare-values image-z)
  1210.   (let ((pixarray (if (and (eq (image-x-format image) :xy-pixmap)
  1211.                (> (image-depth image) 1))
  1212.               (error "Conversion from :XY-PIXMAP to image-z not supported")
  1213.               (z-format-pixarray (image-x-data image) 0 (image-x-bytes-per-line image)
  1214.                      (image-depth image) (image-x-bits-per-pixel image)
  1215.                      x y width height))))
  1216.     (create-image :width width :height height :plist (image-plist image)
  1217.           :depth (image-x-depth image)
  1218.           :data pixarray)))
  1219.  
  1220. (defun image-x->image-xy (image x y width height)
  1221.   (declare (type image-x image)
  1222.        (type card16 x y width height))
  1223.   (declare-values image-xy)
  1224.   (if (eq (image-x-format image) :z-pixmap)
  1225.       (error "Conversion from :Z-PIXMAP to IMAGE-XY not supported")
  1226.     (do* ((depth (image-depth image))
  1227.       (plane 0 (1+ plane))
  1228.       (bytes-per-line (image-x-bytes-per-line image))
  1229.       (bytes-per-plane (* bytes-per-line (image-height image)))
  1230.       (start 0 (+ start bytes-per-plane))
  1231.       (data (image-x-data image))
  1232.       (result nil))
  1233.     ((>= plane depth)
  1234.      (create-image :width width :height height
  1235.                :depth depth :data (nreverse result)
  1236.                ))
  1237.       (push (z-format-pixarray data start bytes-per-line 1 1
  1238.                    x y width height)
  1239.         result))))
  1240.  
  1241. (defun image-xy->image-x (image x y width height)
  1242.   (let* ((depth (image-depth image))
  1243.      (bytes-per-line (ceiling width 8))
  1244.      (bitmaps (image-xy-bitmap-list image))
  1245.      (length (* height bytes-per-line depth))
  1246.      (vector (make-array length :element-type 'card8)))
  1247.     (dolist (bitmap bitmaps)
  1248.       (copy-pixarray-to-vector vector bitmap 1 bytes-per-line
  1249.                    x y width height))
  1250.     (create-image :width width :height height :depth depth :plist (image-plist image)
  1251.           :format :xy-pixmap :bytes-per-line bytes-per-line
  1252.           :data vector)))
  1253.  
  1254. (defun image-z->image-x (image x y width height)
  1255.   (let* ((bits-per-pixel (image-z-bits-per-pixel image))
  1256.      (bytes-per-line (ceiling (* width bits-per-pixel) 8))
  1257.      (length (* height bytes-per-line))
  1258.      (vector (make-array length :element-type 'card8)))
  1259.     (copy-pixarray-to-vector vector (image-z-pixarray image) bits-per-pixel bytes-per-line
  1260.                  x y width height)
  1261.     (create-image :width width :height height :depth (image-depth image)
  1262.           :plist (image-plist image) :bits-per-pixel bits-per-pixel
  1263.           :format :z-pixmap :bytes-per-line bytes-per-line
  1264.           :data vector)))
  1265.  
  1266. (defun copy-pixarray-to-vector (vector pixarray bits-per-pixel bytes-per-line src-x src-y width height)
  1267.   (declare (type pixarray pixarray)
  1268.        (type (member 1 4 8 16 24 32) bits-per-pixel)
  1269.        (type card16 src-x src-y width height))
  1270.   (let* ((row src-y)
  1271.      (copy-pixarray-row (cdr (assoc bits-per-pixel
  1272.                     '((1 . copy-pixarray-row-1)
  1273.                       (4 . copy-pixarray-row-4)
  1274.                       (8 . copy-pixarray-row-8)
  1275.                       (16 . copy-pixarray-row-16)
  1276.                       (24 . copy-pixarray-row-24)
  1277.                       (32 . copy-pixarray-row-32)))))
  1278.      (boffset 0))
  1279.     (declare (type array-index row boffset))
  1280.     (dotimes (i height)
  1281.       ;; Copy scanline
  1282.       (funcall copy-pixarray-row vector boffset pixarray row src-x width)
  1283.       (index-incf row)
  1284.       (index-incf boffset bytes-per-line))))
  1285.  
  1286. (defun image-xy->image-z (image x y width height)
  1287.   image x y width height ;; unused
  1288.   (error "Conversion of image-xy to image-z not supported"))
  1289.  
  1290. (defun image-z->image-xy (image x y width height)
  1291.   image x y width height ;; unused
  1292.   (error "Conversion of image-z to image-xy not supported"))
  1293.  
  1294.  
  1295. ;;;-----------------------------------------------------------------------------
  1296. ;;; Image I/O functions
  1297.  
  1298.  
  1299. (defun read-bitmap-file (pathname)
  1300.   ;; Creates an image from a C include file in standard X11 format
  1301.   (declare (type (or pathname string stream) pathname))
  1302.   (declare-values image)
  1303.   (with-open-file (fstream pathname :direction :input)
  1304.     (let ((line "")
  1305.       (name nil)
  1306.       (properties nil)
  1307.       (start nil))
  1308.       (declare (type string line)
  1309.            (type stringable name)
  1310.            (type list properties)
  1311.            (type (or null array-index) start))
  1312.       (with-vector (line string)
  1313.     ;; Get properties
  1314.     (loop
  1315.       (setq line (read-line fstream))
  1316.       (unless (eql (aref line 0) #\#)
  1317.         (return))
  1318.       (unless start (setq start (position #\_ line :from-end t)))
  1319.       (let ((*package* (find-package 'keyword))
  1320.         (value 0)
  1321.         property)
  1322.         (setq name (read-from-string line t nil :start 7 :end start))
  1323.         (multiple-value-setq (property value)
  1324.           (read-from-string line t nil :start (1+ start)))
  1325.         (setf (getf properties property) (read-from-string line t nil :start value))))
  1326.     (when name (setf (getf properties :name) name))
  1327.     ;; Calculate sizes
  1328.     (let* ((width (getf properties :width))
  1329.            (height (getf properties :height))
  1330.            (depth (getf properties :depth 1)))
  1331.       (declare (type (or null card16) width height))
  1332.       (unless (and width height)
  1333.         (error "Not a BITMAP file"))
  1334.       (let* ((byte-width (ceiling (* width depth) 8))
  1335.          (line-width (* 4 (ceiling (* width depth) 32)))
  1336.          (data (make-array (* line-width height)
  1337.                    :element-type '(unsigned-byte 8)))
  1338.          (number-string (make-string 2))
  1339.          (line-base 0)
  1340.          (byte 0))
  1341.         (declare (type card16 byte-width line-width line-base byte)
  1342.              (type string number-string)
  1343.              (type (simple-array card8 (*)) data))
  1344.         (with-vector (data (simple-array card8 (*)))
  1345.           ;; Read data
  1346.           (dotimes (i height)
  1347.         (dotimes (j byte-width)
  1348.           (loop (when (eql (read-char fstream) #\x) (return)))
  1349.           (setf (aref number-string 0) (read-char fstream))
  1350.           (setf (aref number-string 1) (read-char fstream))
  1351.           (setf (aref data (+ line-base byte))
  1352.             (parse-integer number-string :radix 16. :junk-allowed t))
  1353.           (incf byte))
  1354.         (setq byte 0
  1355.               line-base (+ line-base line-width)))
  1356.           (create-image :width width :height height :depth depth
  1357.                 :plist properties :data data
  1358.                 :bit-lsb-first-p t ;; WHY? (sounds like a bug)
  1359.                 ))))))))
  1360.  
  1361. (defun write-bitmap-file (pathname image &optional name)
  1362.   ;; Writes an image to a C include file in standard X11 format
  1363.   ;; NAME argument used for variable prefixes.  Defaults to "image"
  1364.   (declare (type (or pathname string stream) pathname)
  1365.        (type image image)
  1366.        (type (or null stringable) name))
  1367.   (unless (typep image 'image-x)
  1368.     (setq image (copy-image image :result-type 'image-x)))
  1369.   (when (and (= (image-depth image) 1)
  1370.          (not (image-x-bit-lsb-first-p image)))
  1371.     (bit-reverse-image image))
  1372.   (let* ((plist (image-plist image))
  1373.      (name (or name (image-name image) 'image))
  1374.      (width (image-width image))
  1375.      (height (image-height image))
  1376.      (depth (image-depth image))
  1377.      (data (image-x-data image))
  1378.      (byte-width (ceiling (* width depth) 8))
  1379.      (line-width (* 4 (ceiling (* width depth) 32)))
  1380.      (line 0)
  1381.      (byte-number 0)
  1382.      (count 0))
  1383.     (declare (type list plist)
  1384.          (type stringable name)
  1385.          (type card16 width height)
  1386.          (type card16 byte-width line-width line byte-number count)
  1387.          (type (simple-array card8 (*)) data))
  1388.     (with-vector (data (simple-array card8 (*)))
  1389.       (setq name (string-downcase (string name)))
  1390.       (with-open-file (fstream pathname :direction :output)
  1391.     (format fstream "#define ~a_width ~d~%" name width)
  1392.     (format fstream "#define ~a_height ~d~%" name height)
  1393.     (unless (= depth 1)
  1394.       (format fstream "#define ~a_depth ~d~%" name depth))
  1395.     (do ((prop plist (cddr prop)))
  1396.         ((endp prop))
  1397.       (when (and (not (member (car prop) '(:width :height)))
  1398.              (numberp (cadr prop)))
  1399.         (format fstream "#define ~a_~a ~d~%"
  1400.             name (string-downcase (string (car prop))) (cadr prop))))
  1401.     (format fstream "static char ~a_bits[] = {" name)
  1402.     (dotimes (i height)
  1403.       (dotimes (j byte-width)
  1404.         (when (zerop (mod count 12)) (format fstream "~%  "))
  1405.         (write-string " 0x" fstream)
  1406.         ;; Faster than (format fstream "0x~2,'0x," byte)
  1407.         (let ((byte (aref data (+ line byte-number)))
  1408.           (translate "0123456789abcdef"))
  1409.           (write-char (aref translate (ldb (byte 4 4) byte)) fstream)
  1410.           (write-char (aref translate (ldb (byte 4 0) byte)) fstream)
  1411.           (incf byte-number)
  1412.           (incf count)
  1413.           (unless (and (= (1+ i) height)
  1414.                (= (1+ j) byte-width))
  1415.         (write-char #\, fstream))))
  1416.       (setq byte-number 0
  1417.         line (+ line line-width)))
  1418.     (format fstream "};~%" fstream)))))
  1419.  
  1420.  
  1421. (defun bitmap-image (&optional plist &rest patterns)
  1422.   ;; Create an image containg pattern
  1423.   ;; PATTERNS are bit-vector constants (e.g. #*10101)
  1424.   ;; If the first parameter is a list, its used as the image property-list.
  1425.   (declare (type (or list bit-vector) plist)
  1426.        (type list patterns)) ;; list of bitvector
  1427.   (declare-values image)
  1428.   (unless (listp plist)
  1429.     (push plist patterns)
  1430.     (setq plist nil))
  1431.   (let* ((width (length (first patterns)))
  1432.      (height (length patterns))
  1433.      (bitarray (make-array (list height width) :element-type 'bit))
  1434.      (row 0))
  1435.     (dolist (pattern patterns)
  1436.       (dotimes (col width)
  1437.     (setf (aref bitarray row col) (aref pattern col)))
  1438.       (incf row))
  1439.     (create-image :width width :height height :plist plist :data bitarray)))
  1440.  
  1441. (defun image-pixmap (drawable image &key gcontext width height depth)
  1442.   ;; Create a pixmap containing IMAGE. Size defaults from the image.
  1443.   ;; DEPTH is the pixmap depth.
  1444.   ;; GCONTEXT is used for putting the image into the pixmap.
  1445.   ;; If none is supplied, then one is created, used then freed.
  1446.   (declare (type drawable drawable)
  1447.        (type image image)
  1448.        (type (or null gcontext) gcontext)
  1449.        (type (or null card16) width height)
  1450.        (type (or null card8) depth))
  1451.   (declare-values pixmap)
  1452.   (let* ((image-width (image-width image))
  1453.      (image-height (image-height image))
  1454.      (image-depth (image-depth image))
  1455.      (width (or width image-width))
  1456.      (height (or height image-height))
  1457.      (depth (or depth image-depth))
  1458.      (pixmap (create-pixmap :drawable drawable
  1459.                    :width width
  1460.                    :height height
  1461.                    :depth depth))
  1462.      (gc (or gcontext (create-gcontext
  1463.                 :drawable pixmap
  1464.                 :foreground 1
  1465.                 :background 0))))
  1466.     (unless (= depth image-depth)
  1467.       (if (= image-depth 1)
  1468.       (unless gcontext (xlib::required-arg gcontext))
  1469.     (error "Pixmap depth ~d incompatable with image depth ~d"
  1470.            depth image-depth)))           
  1471.     (put-image pixmap gc image :x 0 :y 0
  1472.            :bitmap-p (and (= image-depth 1)
  1473.                   gcontext))
  1474.     ;; Tile when image-width is less than the pixmap width, or
  1475.     ;; the image-height is less than the pixmap height.
  1476.     ;; ??? Would it be better to create a temporary pixmap and 
  1477.     ;; ??? let the server do the tileing?
  1478.     (do ((x image-width (+ x image-width)))
  1479.     ((>= x width))
  1480.       (copy-area pixmap gc 0 0 image-width image-height pixmap x 0)
  1481.       (incf image-width image-width))
  1482.     (do ((y image-height (+ y image-height)))
  1483.     ((>= y height))
  1484.       (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y)
  1485.       (incf image-height image-height))
  1486.     (unless gcontext (free-gcontext gc))
  1487.     pixmap))
  1488.  
  1489.